home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / McCartney-library 1.1 / CODE / views / scatter-plot-view.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  9.6 KB  |  251 lines  |  [TEXT/CCL2]
  1. ;;; scatter-plot-view.lisp
  2. ;;;
  3. ;;; Paul McCartney, Spring 1992
  4. ;;;
  5. ;;; Copyright © 1992 Paul McCartney.  All Rights Reserved.
  6. ;;; 
  7. ;;; Washington University Medical Informatics Training Program
  8. ;;;
  9. ;;; DESCRIPTION:
  10. ;;;
  11. ;;; This is a generalized view for a scatter plot.  Given a list of data points,
  12. ;;; create a view to display the data in a two-dimensionally.  This module,
  13. ;;; by itself, provides the control for this process but does not provide the 
  14. ;;; specifics for particular scatter plots.  These objects should be specialized
  15. ;;; with particular functions being overridden.
  16. ;;;
  17. ;;; USE:
  18. ;;;
  19. ;;; scatter-plot-view  -   view object for the scatter plot view.
  20. ;;;   :x-start         -   horizontal start value
  21. ;;;   :x-end           -   horizontal end value
  22. ;;;   :y-start         -   vertical start value
  23. ;;;   :y-end           -   vertical end value
  24. ;;;   :inverted-p      -   whether the vertical start begins at the top (nil)
  25. ;;;                        or the bottom (t)
  26. ;;;   :x-value-fn      -   return the x component of a data value
  27. ;;;   :y-value-fn      -   return the y component of a data value
  28. ;;;   :click-on-point-function - function to be performed when a point is clicked on
  29. ;;;
  30. ;;; scatter-plot-point -   point object for data in the scatter plot view.
  31. ;;; add-scatter-plot-points  -  add a set of data to the scatter plot
  32. ;;; set-scatter-plot-x-scale -  set the scatter plot x scale
  33. ;;; set-scatter-plot-y-scale -  set the scatter plot y scale
  34. ;;; set-scatter-plot-origin     - set the data values for the upper left corner of the
  35. ;;;                               view and scroll as needed.
  36. ;;; draw-scatter-plot-point     - method to draw scatter-plot-point
  37. ;;;
  38. ;;; HISTORY:
  39. ;;;
  40. ;;; 7/17/92 Optimized scrolling.  - PM
  41. ;;; 6/3/92 Created.  - PM
  42. ;;;
  43.  
  44. (in-package :ccl)
  45.  
  46. (require :quickdraw)
  47. (require :GWorld-view-extensions)
  48.  
  49. (eval-when (:compile-toplevel :load-toplevel :execute)
  50.   (export '(scatter-plot-view scatter-plot-point add-scatter-plot-points 
  51.             set-scatter-plot-range scatter-plot-points draw-scatter-plot-point
  52.             spp-data spp-topleft spp-bottomright)
  53.           :ccl))
  54.  
  55.  
  56. ;;; This is the view object for the scatter plot view.  It should not be 
  57. ;;; used directly; instead, it should be specialized, overriding its key
  58. ;;; functions.
  59. ;;;
  60. (defclass scatter-plot-view (view)
  61.   ((scatter-plot-points :initarg :scatter-plot-points :accessor scatter-plot-points)
  62.    (inverted-p :initarg :inverted-p :accessor inverted-p)
  63.    (x-scale :initarg :x-scale :accessor x-scale)
  64.    (y-scale :initarg :y-scale :accessor y-scale)
  65.    (x-start :initarg :x-start :accessor x-start)
  66.    (y-start :initarg :y-start :accessor y-start)
  67.    (x-end :initarg :x-end :accessor x-end)
  68.    (y-end :initarg :y-end :accessor y-end)
  69.    (x-value-fn :initarg :x-value-fn :accessor x-value-fn)
  70.    (y-value-fn :initarg :y-value-fn :accessor y-value-fn)
  71.    (click-on-point-function :initarg :click-on-point-function :accessor click-on-point-function)
  72.    (click-on-hidden-points-p :initarg :click-on-hidden-points-p :accessor click-on-hidden-points-p)
  73.    )
  74.   (:default-initargs
  75.     :view-position #@(0 0)
  76.     :view-size #@(100 100)
  77.     :scatter-plot-points nil
  78.     :inverted-p t
  79.     :x-scale 1
  80.     :y-scale 1
  81.     :x-start 0
  82.     :x-end 10
  83.     :y-start 0
  84.     :y-end 10
  85.     :x-value-fn #'first
  86.     :y-value-fn #'second
  87.     :click-on-point-function #'(lambda (view point) (declare (ignore view point)))
  88.     :click-on-hidden-points-p nil
  89.     )
  90.   )
  91.  
  92.  
  93. ;;; This is the view object for the scatter plot point.  It should not be 
  94. ;;; used directly; instead, it should be specialized, overriding its key
  95. ;;; functions.
  96. ;;;
  97. (defclass scatter-plot-point ()
  98.   ((spp-data :initarg :spp-data :accessor spp-data)
  99.    (spp-size :initarg :spp-size :accessor spp-size)
  100.    (spp-topleft :initarg :spp-topleft :accessor spp-topleft)
  101.    (spp-bottomright :initarg :spp-bottomright :accessor spp-bottomright))
  102. )
  103.  
  104.  
  105. ;;;;
  106. ;;;; SCATTER PLOT VIEW
  107. ;;;;
  108.  
  109. (defmethod set-view-size ((view scatter-plot-view) h &optional v)
  110.   (call-next-method view h v)
  111.   (set-scatter-plot-range view (x-start view) (x-end view) (y-start view) (y-end view))
  112.   (set-point-positions view))
  113.  
  114.  
  115. ;;; This is a special view-draw-contents that takes care of determining if
  116. ;;; a scatter plot point is visible and should be displayed.  If so, the
  117. ;;; generic function "draw-scatter-plot-point" is called with the point and
  118. ;;; the view.
  119. ;;;
  120. (defmethod view-draw-contents ((view scatter-plot-view))  
  121.   (let* ((region (intersect-region (rref (wptr view) grafport.visrgn) 
  122.                                    (rref (wptr view) grafport.cliprgn)))
  123.          (top (href region :Region.rgnBBox.top))
  124.          (left (href region :Region.rgnBBox.left))
  125.          (right (href region :Region.rgnBBox.right))
  126.          (bottom (href region :Region.rgnBBox.bottom)))
  127.     (with-GWorld-no-colorization (view left top right bottom)
  128.       (dolist (point (scatter-plot-points view))
  129.         (when (rect-in-region-p region (spp-topleft point) (spp-bottomright point))
  130.           (draw-scatter-plot-point 
  131.            point 
  132.            *GW-offscreen-view*
  133.            (make-GW-point (spp-topleft point))
  134.            (make-GW-point (spp-bottomright point))) )))
  135.     (dispose-region region) ))
  136.  
  137.  
  138. (defmethod view-click-event-handler ((view scatter-plot-view) where)
  139.   (call-next-method)
  140.   (let ((done nil))
  141.     (dolist (point (reverse (scatter-plot-points view)))
  142.       (rlet ((r :rect 
  143.                 :topleft (spp-topleft point) 
  144.                 :bottomright (spp-bottomright point)))
  145.         (when (and (not done) (point-in-rect-p r where))
  146.           (when (not (click-on-hidden-points-p view))
  147.             (setf done t))
  148.           (funcall (click-on-point-function view) view (spp-data point))))) ))
  149.  
  150.  
  151. (defmethod add-scatter-plot-points ((view scatter-plot-view) data-points
  152.                                     &optional (type 'scatter-plot-point)
  153.                                               (clear nil)
  154.                                               (size 5))
  155.   (if clear
  156.     (setf (scatter-plot-points view) ()))
  157.  
  158.   (dolist (data data-points)
  159.     (let ((point (make-instance type :spp-data data :spp-size size)))
  160.       (push point (scatter-plot-points view))))
  161.  
  162.   (set-point-positions view) )
  163.  
  164.  
  165. (defmethod set-point-positions ((view scatter-plot-view))
  166.   (dolist (point (scatter-plot-points view))
  167.     (let* ((x (point-value-in-range (scatter-plot-point-x-value view (spp-data point))))
  168.            (y (point-value-in-range (scatter-plot-point-y-value view (spp-data point))))
  169.            (half-size (point-value-in-range (round (spp-size point) 2)))
  170.            (half-size-point (make-point half-size half-size)))
  171.       
  172.       (setf (spp-topleft point) (subtract-points (make-point x y) half-size-point))
  173.       (setf (spp-bottomright point) (add-points (make-point x y) half-size-point)) )))
  174.  
  175.  
  176. (defmethod scatter-plot-point-x-value ((view scatter-plot-view) data &optional value)
  177.   (round (* (x-scale view) 
  178.             (- (or value (funcall (x-value-fn view) data)) (x-start view)))))
  179.  
  180.  
  181. (defmethod scatter-plot-point-y-value ((view scatter-plot-view) data &optional value)
  182.   (let ((y-pos (round (* (y-scale view) 
  183.                          (- (or value (funcall (y-value-fn view) data)) (y-start view))))))
  184.     (if (inverted-p view)
  185.       (- (point-v (view-size view)) y-pos)
  186.       y-pos)))
  187.  
  188.  
  189. (defmethod set-scatter-plot-range ((view scatter-plot-view) x-start x-end y-start y-end)
  190.   (let ((old-x-scale (x-scale view))
  191.         (old-y-scale (y-scale view))
  192.         (old-x-start (x-start view))
  193.         (old-y-start (y-start view))
  194.         (x-scale (/ (point-h (view-size view)) (- x-end x-start)))
  195.         (y-scale (/ (point-v (view-size view)) (- y-end y-start))))
  196.     (setf (x-start view) x-start)
  197.     (setf (x-end view) x-end) 
  198.     (setf (y-start view) y-start)
  199.     (setf (y-end view) y-end)
  200.     (setf (x-scale view) x-scale)
  201.     (setf (y-scale view) y-scale)
  202.     
  203.     (let* ((scroll-change (or (/= old-x-start x-start)
  204.                               (/= old-y-start y-start)))
  205.            (scale-change (or (/= x-scale old-x-scale) (/= y-scale old-y-scale))))
  206.       (when (or scale-change scroll-change)
  207.         (set-point-positions view))
  208.  
  209.       (cond ((and scroll-change (not scale-change))
  210.              (scatter-plot-view-scroll view old-x-start old-y-start x-start y-start))
  211.             ((or scale-change scroll-change) 
  212.              (invalidate-view view))) )))
  213.  
  214.  
  215. (defmethod scatter-plot-view-scroll ((view scatter-plot-view) old-x-start old-y-start x-start y-start)
  216.   (let* ((dh (- (scatter-plot-point-x-value view nil old-x-start)
  217.                 (scatter-plot-point-x-value view nil x-start)))
  218.          (dv (if (inverted-p view)
  219.                (- (scatter-plot-point-y-value view nil old-y-start)
  220.                   (scatter-plot-point-y-value view nil y-start))
  221.                (- (scatter-plot-point-y-value view nil y-start)
  222.                   (scatter-plot-point-y-value view nil old-y-start)))))
  223.     (with-focused-view view
  224.       (rlet ((rect :rect :topleft #@(0 0) :bottomright (view-size view)))
  225.         (let* ((reg (#_newrgn)))
  226.           (#_ScrollRect :ptr rect
  227.            :long (make-point dh dv)
  228.            :ptr reg)
  229.           (#_invalrgn reg)
  230.           (#_disposergn reg)))) ))
  231.  
  232.  
  233. ;;;;
  234. ;;;; SCATTER PLOT POINT GENERIC FUNCTIONS
  235. ;;;;
  236.  
  237. ;;; GENERIC FUNCTION:  Specialize me
  238. ;;;
  239. ;;; This is a generic function which should be overriden.
  240. ;;; By default, draw a filled in circle.  Inherited functions should NOT 
  241. ;;; call-next-method, as this would draw the circle on top of whatever else
  242. ;;; is drawn first.  Note that the view is focused when this is called, so
  243. ;;; focusing is not necessary.
  244. ;;;
  245. (defmethod draw-scatter-plot-point ((point scatter-plot-point) view topleft bottomright)
  246.   (rlet ((r :rect :topleft topleft :bottomright bottomright))
  247.     (with-focused-view view
  248.       (#_PaintOval r)) ))
  249.  
  250.  
  251. (provide :scatter-plot-view)